home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Smltop.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  9.8 KB  |  293 lines  |  [TEXT/R*ch]
  1. (* Smltop.sml *)
  2.  
  3. open List Obj BasicIO Nonstdio;
  4. open Miscsys Memory Fnlib Config Mixture Const Smlexc Smlprim;
  5. open Globals Location Units Types Smlperv Code_dec Emitcode Emit_phr Compiler;
  6. open Symtable Patch;
  7. open Rtvals Load_phr Exec_phr;
  8.  
  9. exception Already of string
  10. and NotYet of string
  11.  
  12. fun add_suffix name suffix =
  13.   if Filename.check_suffix name suffix
  14.   then (Filename.chop_suffix name suffix, name)
  15.   else (name, name ^ suffix)
  16. ;
  17.  
  18. (* Loading in core a compiled bytecode file *)
  19.  
  20. fun tryEvalLoad name =
  21.   let
  22.     val (simplename, filename) = add_suffix name ".uo"
  23.     val uname = normalizedUnitName(Filename.basename simplename)
  24.     val () =
  25.       if member uname reservedUnitNames then
  26.         raise Fail ("load: cannot load built-in unit "^uname)
  27.       else ()
  28.     val () =
  29.       (ignore (Hasht.find (!watchDog) uname);
  30.        raise Already uname)
  31.       handle Subscript => ()
  32.     val block_len = ref 0
  33.     val code = ref ""
  34.     val truename = find_in_path filename
  35.     val is = open_in_bin truename
  36.     val () =
  37.       let
  38.         val stop = input_binary_int is
  39.         val start = pos_in is
  40.         val code_len = stop - start
  41.         val () = (block_len := code_len + 1)
  42.         (* Now we have to check, whether the unit body is compatible *)
  43.         (* with its compiled signature and previously loaded units. *)
  44.         val () = seek_in is stop
  45.         val tables = (input_value is : compiled_unit_tables)
  46.         val () =
  47.           Hasht.apply (fn uname' => fn stamp' =>
  48.               let val stamp'' = Hasht.find (!watchDog) uname' in
  49.                 if stamp'' <> stamp' then
  50.                   raise Fail ("load: compiled body of unit "^uname^
  51.                      " is incompatible with previously loaded unit "^
  52.                      uname')
  53.                 else ()
  54.               end
  55.               handle Subscript => raise NotYet uname')
  56.             (#cu_mentions tables)
  57.         (* The following line will cause the compiled signature *)
  58.         (* to be put into the current table of unit signatures (if not there)! *)
  59.         val sig = (Hasht.find (!currentSigTable) uname
  60.                    handle Subscript => readSig uname)
  61.         prim_val set_nth_char_ : string -> int -> char -> unit
  62.                                                  = 3 "set_nth_char"
  63.       in
  64.         if #cu_sig_stamp tables <> getOption (!(#uStamp sig)) then
  65.            raise Fail ("load: compiled body of unit "^uname^
  66.                        " is incompatible with its compiled signature")
  67.         else ();
  68.         seek_in is start;
  69.         code := static_alloc (!block_len);
  70.         fast_really_input is (!code) 0 code_len;
  71.         (* `set_nth_char' must not check the length of buff, *)
  72.         (* because `code' is allocated outside the heap! *)
  73.         set_nth_char_ (!code) code_len (Char.chr Opcodes.STOP);
  74.         app
  75.           (fn phr =>
  76.             patch_object (!code) ((#cph_pos phr) - start) (#cph_reloc phr))
  77.           (rev (#cu_phrase_index tables));
  78.         exportPublicNames uname
  79.           (#cu_exc_ren_list tables) (#cu_val_ren_list tables);
  80.         Hasht.insert (!currentSigTable) uname sig;
  81.         Hasht.insert (!watchDog) uname (#cu_sig_stamp tables);
  82.         close_in is
  83.       end
  84.       handle x =>
  85.         (close_in is; raise x)
  86.     val res = do_code false (!code) 0 (!block_len)
  87.   in () end
  88. ;
  89.  
  90. fun evalLoad s =
  91.   (catch_interrupt false; tryEvalLoad s; catch_interrupt true)
  92.   handle
  93.        Io s =>
  94.          (catch_interrupt true; raise Fail ("load: "^s))
  95.      | Already uname =>
  96.          (catch_interrupt true;
  97.       raise Fail ("load: unit "^uname^" has been loaded already"))
  98.      | NotYet uname =>
  99.          (catch_interrupt true;
  100.       raise Fail ("load: unit "^uname^" is needed but not yet loaded"))
  101.      | Out_of_memory =>
  102.          (catch_interrupt true; raise Fail "load: out of memory")
  103.      | Toplevel =>
  104.          (catch_interrupt true;
  105.           raise Fail "load: unable to load")
  106.      | x => (catch_interrupt true; raise x)
  107. ;
  108.  
  109. (* A more user-friendly load function:
  110.    * does not fail when a unit has already been loaded;
  111.    * automatically loads any unit that a requested unit depends on.
  112. *)
  113.  
  114. fun smartEvalLoad s =
  115.     let fun tryload s pending =
  116.     (catch_interrupt false; tryEvalLoad s; catch_interrupt true)
  117.     handle
  118.     Io s =>
  119.         (catch_interrupt true; raise Fail ("load: "^s))
  120.       | Already _ =>
  121.         catch_interrupt true
  122.       | NotYet missing =>
  123.         (catch_interrupt true;
  124.          if member missing pending then
  125.          raise Fail ("load: unit " ^ missing ^
  126.                  " indirectly depends on itself")
  127.          else
  128.          (tryload missing (s :: pending);
  129.           tryload s pending))
  130.       | Out_of_memory =>
  131.         (catch_interrupt true; raise Fail "load: out of memory")
  132.       | Toplevel =>
  133.         (catch_interrupt true;
  134.          raise Fail "load: unable to load")
  135.       | x => (catch_interrupt true; raise x)
  136.     in tryload s [] end
  137. ;
  138.  
  139. fun protect_current_input fct =
  140.   let val saved_input_name = !input_name
  141.       and saved_input_stream = !input_stream
  142.       and saved_input_lexbuf = !input_lexbuf
  143.   in
  144.     (fct();
  145.      input_lexbuf := saved_input_lexbuf;
  146.      input_stream := saved_input_stream;
  147.      input_name := saved_input_name)
  148.     handle x =>
  149.       (input_lexbuf := saved_input_lexbuf;
  150.        input_stream := saved_input_stream;
  151.        input_name := saved_input_name;
  152.        raise x)
  153.   end
  154. ;
  155.  
  156. (* Loading an SML source file *)
  157.  
  158. fun loadToplevelPhrase lexbuf =
  159.   let val (phrase, isLast) = parseToplevelPhrase lexbuf in
  160.     execToplevelPhrase phrase;
  161.     isLast
  162.   end
  163. ;
  164.  
  165. fun evalUse filename =
  166.   let
  167.     val truename =
  168.       (find_in_path filename
  169.        handle Fail msg =>
  170.          (msgIBlock 0; errPrompt msg; msgEOL(); msgEBlock(); msgFlush();
  171.           raise Toplevel))
  172.     val () = (msgIBlock 0;
  173.               msgString "[opening file \""; msgString truename;
  174.               msgString "\"]"; msgEOL(); msgEBlock(); msgFlush())
  175.     val is = open_in_bin truename
  176.     val lexbuf = Compiler.createLexerStream is
  177.     fun closeIn() =
  178.       (close_in is;
  179.        msgIBlock 0;
  180.        msgString "[closing file \""; msgString truename;
  181.        msgString "\"]"; msgEOL(); msgEBlock(); msgFlush())
  182.   in
  183.     ( protect_current_input (fn () =>
  184.         (input_name := truename;
  185.          input_stream := is;
  186.          input_lexbuf := lexbuf;
  187.          while true do
  188.            let val isLast = loadToplevelPhrase lexbuf
  189.            in if isLast then raise EndOfFile else () end)))
  190.     handle
  191.         EndOfFile => closeIn()
  192.       | x => (closeIn(); raise x)
  193.   end
  194. ;
  195.  
  196. (* Compile a file *)
  197.  
  198. fun tryEvalCompile s =
  199.   protect_current_input (fn () => protectCurrentUnit (fn () =>
  200.     if Filename.check_suffix s ".sig" then
  201.       let val filename = Filename.chop_suffix s ".sig" in
  202.         compileSignature
  203.           (normalizedUnitName (Filename.basename filename))
  204.           filename
  205.       end
  206.     else if Filename.check_suffix s ".sml" then
  207.       let val filename = Filename.chop_suffix s ".sml" in
  208.         compileUnitBody
  209.           (normalizedUnitName (Filename.basename filename))
  210.           filename
  211.       end
  212.     else
  213.       raise Fail "compile: unknown file name extension"))
  214. ;
  215.  
  216. fun evalCompile s =
  217.   tryEvalCompile s
  218.   handle
  219.        Interrupt => raise Fail "compile: interrupted by the user"
  220.      | Out_of_memory => raise Fail "compile: out of memory"
  221.      | Toplevel => raise Fail "compile: error(s) in the source program"
  222. ;
  223.  
  224. val smltop_con_basis =
  225. [
  226.   ("use",    { qualid={qual="Meta", id="use"},     info=VARname REGULARo}),
  227.   ("load",   { qualid={qual="Meta", id="load"},    info=VARname REGULARo}),
  228.   ("loadOne",{ qualid={qual="Meta", id="loadOne"}, info=VARname REGULARo}),
  229.   ("compile",{ qualid={qual="Meta", id="compile"}, info=VARname REGULARo}),
  230.   ("verbose",{ qualid={qual="Meta", id="verbose"}, info=VARname REGULARo}),
  231.   ("quotation",
  232.              { qualid={qual="Meta", id="quotation"}, info=VARname REGULARo}),
  233.   ("print",  { qualid={qual="Meta", id="print"},   info=VARname OVL1TXXo}),
  234.   ("printDepth",
  235.              { qualid={qual="Meta", id="printDepth"}, info=VARname REGULARo}),
  236.   ("printLength",
  237.              { qualid={qual="Meta", id="printLength"}, info=VARname REGULARo}),
  238.   ("system", { qualid={qual="Meta", id="system"},
  239.                info=PRIMname (mkPrimInfo 1 (MLPccall(1, "sml_system"))) }),
  240.   ("exit",   { qualid={qual="Meta", id="exit"},    info=VARname REGULARo}),
  241.   ("quit",   { qualid={qual="Meta", id="quit"},    info=VARname REGULARo}),
  242.   ("installPP",
  243.              { qualid={qual="Meta", id="installPP"}, info=VARname OVL1TPUo})
  244. ];
  245.  
  246. val smltop_VE =
  247. [
  248.    ("use",         trivial_scheme(type_arrow type_string type_unit)),
  249.    ("load",        trivial_scheme(type_arrow type_string type_unit)),
  250.    ("loadOne",     trivial_scheme(type_arrow type_string type_unit)),
  251.    ("compile",     trivial_scheme(type_arrow type_string type_unit)),
  252.    ("verbose",     trivial_scheme(type_ref type_bool)),
  253.    ("quotation",   trivial_scheme(type_ref type_bool)),
  254.    ("printDepth",  trivial_scheme (type_ref type_int)),
  255.    ("printLength", trivial_scheme (type_ref type_int)),
  256.    ("system",      trivial_scheme(type_arrow type_string type_int)),
  257.    ("exit",        scheme_1u (fn a => type_arrow type_int a)),
  258.    ("quit",        scheme_1u (fn a => type_arrow type_unit a))
  259. ];
  260.  
  261. val unit_smltop = newSig "Meta";
  262.  
  263. val () =
  264.   app
  265.     (fn (id, status) => Hasht.insert (#uConBasis unit_smltop) id status)
  266.     smltop_con_basis
  267. ;
  268.  
  269. val () =
  270.   app
  271.     (fn (id, sc) => Hasht.insert (#uVarEnv unit_smltop) id sc)
  272.     smltop_VE
  273. ;
  274.  
  275. val () = Hasht.insert pervSigTable "Meta" unit_smltop;
  276.  
  277. fun resetSMLTopDynEnv() =
  278.   loadGlobalDynEnv "Meta" [
  279.     ("use",         repr (evalUse: string -> unit)),
  280.     ("loadOne",     repr evalLoad),
  281.     ("load",        repr smartEvalLoad),
  282.     ("compile",     repr evalCompile),
  283.     ("verbose",     repr verbose),
  284.     ("quotation",   repr Lexer.quotation),
  285.     ("print",       repr evalPrint),
  286.     ("printDepth",  repr printDepth),
  287.     ("printLength", repr printLength),
  288.     ("exit",        repr (fn n => (msgFlush(); BasicIO.exit n))),
  289.     ("quit",        repr (fn () => (msgFlush(); BasicIO.exit 0))),
  290.     ("installPP",   repr evalInstallPP)
  291. ];
  292.  
  293.